package require dns 1.3.1
package require ip 1.1.1
catch {package require udp} 
package require TclJs

package provide TclJsPac 0.1

namespace eval ::js::pac {}

proc ::js::pac::isPlainHostName { host } {
    return [expr {[string length $host] && [string first "." $host] < 0}]
}

proc ::js::pac::dnsDomainIs { host domain } {
    set host [string tolower $host]
    set domain [string tolower $domain]
    set t [string range $host end-[expr {[string length $domain]-1}] end]
    return [string equal $domain $t]
}

proc ::js::pac::localHostOrDomainIs { host hostdom } {
    set host [string tolower $host]
    set hostdom [string tolower $hostdom]
    if { [string equal $host $hostdom] } {
	return 1
    }
    if { [string first "." $host] >= 0 } {
	return 0
    }
    set i [string first "." $hostdom]
    if { $i < 0 } { 
	return 0
    }
    incr i -1
    set t [string tolower [string range $hostdom 0 $i]]
    return [string equal $t $host]
}

proc ::js::pac::isResolvable { host } {
    set tok [::dns::resolve $host]
    ::dns::wait $tok
    set stat [::dns::status $tok]
    ::dns::cleanup $tok
    return [string equal $stat "ok"]
}

proc ::js::pac::isInNet { host pattern mask } {
    if { [regexp {^[[:digit:]]+\.[[:digit:]]+\.[[:digit:]]+\.[[:digit:]]+$} $host match] } {
	set addr $host 
    } else {
	set addr [dnsResolve $host]
    }
    if { ![string length $addr] } { 
	return -code error "invalid or unknown host: '$host'"
    }
    set addr [::ip::toInteger $addr]
    set pattern [::ip::toInteger $pattern]
    set mask [::ip::maskToInt $mask]
    return [expr {($addr & $mask) == ($pattern & $mask)}]
}

proc ::js::pac::dnsResolve { host } {
    set tok [::dns::resolve $host]
    ::dns::wait $tok
    if { [string equal [::dns::status $tok] "ok"] } {
	set addr [lindex [::dns::address $tok] 0]
    } else {
	set addr ""
    }
    ::dns::cleanup $tok
    return $addr
}

proc ::js::pac::myIpAddress { {use_dns 1} } {
    if { $use_dns } { 
	set addr [dnsResolve [info hostname]]
	if { [string length $addr] } { 
	    return $addr
	}
    }
    if { [catch {socket -server nocmd -myaddr [info hostname] 0} srvr] } {
	return ""
    }
    set addr [lindex [fconfigure $srvr -sockname] 0]
    close $srvr
    return $addr
}

proc ::js::pac::dnsDomainLevels { host } {
    return [expr {[llength [split $host "."]] - 1}]
}

proc ::js::pac::shExpMatch { str shexp } { 
    return [string match $shexp $str]
}

proc ::js::pac::weekdayRange { wd1 {wd2 "LOC"} {gmt "LOC"} } {
    # Known formats:
    # WD [GMT/LOC]
    # WD1 WD2 [GMT/LOC]
    set wd1 [string toupper $wd1]
    set wd2 [string toupper $wd2]
    set gmt [string toupper $gmt]
    set dl {LOC GMT SUN MON TUE WED THU FRI SAT SUN MON TUE WED THU FRI SAT}
    set wdi1 [lsearch $dl [string toupper $wd1]]
    if { $wdi1 < 2 } {
	return -code error "invalid value for wd1 parameter: $wd1"
    }
    set wdi2 [lsearch $dl [string toupper $wd2]]
    if { $wdi2 < 0 } {
	return -code error "invalid value for wd2 parameter: $wd2"
    }
    if { $wdi2 < 2 } {
	set gmti $wdi2
	set wdi2 $wdi1
    } else {
	set wdi2 [lsearch -start $wdi1 $dl [string toupper $wd2]]
	set gmti [lsearch $dl [string toupper $gmt]]
	if { $gmti < 0 || $gmti > 1 } {
	    return -code error "invalid value for gmt parameter: $gmt"
	}
    }
    set dow [string toupper [clock format [clock seconds] -format {%a} -gmt $gmti]]
    set dowi [lsearch -start $wdi1 $dl [string toupper $dow]]
    return [expr {$wdi1 <= $dowi && $dowi <= $wdi2}]
}

proc ::js::pac::_dateRange { y1 m1 d1 y2 m2 d2 yn mn dn } {
    set tn [expr {$yn*10000+$mn*100+$dn}]
    set t1 [expr {$y1*10000+$m1*100+$d1}]
    set t2 [expr {$y2*10000+$m2*100+$d2}]
    if { $t1 <= $t2 } {
	return [expr {$t1 <= $tn && $tn <= $t2}]
    } else {
	return [expr {$t1 <= $tn || $tn <= $t2}]
    }
}

proc ::js::pac::dateRange { args } {
    # Known formats:
    # D1 [GMT/LOC]
    # D1 D2 [GMT/LOC]
    # M1 [GMT/LOC]
    # M1 M2 [GMT/LOC]
    # Y1 [GMT/LOC]
    # Y1 Y2 [GMT/LOC]
    # D1 M1 [GMT/LOC]
    # D1 M1 D2 M2 [GMT/LOC] 
    # M1 Y1 [GMT/LOC]
    # M1 Y1 M2 Y2 [GMT/LOC]
    # D1 M1 Y1 [GMT/LOC]
    # D1 M1 Y1 D2 M2 Y2 [GMT/LOC]
    set ml {JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC}
    set frmt {}
    foreach arg $args {
	if { [string is integer -strict $arg] } {
	    if { $arg >= 1 && $arg <= 31 } {
		lappend frmt d
	    } else {
		lappend frmt y
	    }
	} else {
	    if { [lsearch -exact $ml [string toupper $arg]] >= 0 } {
		lappend frmt m
	    } else {
		set i [lsearch -exact {LOC GMT} [string toupper $arg]]
		if { $i >= 0 } {
		    lappend frmt $i
		} else {
		    return -code error "invalid arguments: $args"
		}
	    }
	}
    }
    set gmt [lindex $frmt end]
    if { [string equal $gmt "1"] || [string equal $gmt "0"] } { 
	set frmt [lrange $frmt 0 end-1]
    } else {
	set gmt 0
    }
    set dn [clock format [clock seconds] -format {%e} -gmt $gmt]
    set mn [lsearch -exact $ml [string toupper [clock format [clock seconds] -format {%b} -gmt $gmt]]]
    set yn [clock format [clock seconds] -format {%Y} -gmt $gmt]
    switch -exact -- $frmt {
	{d} {
	    foreach d $args { break }
	    return [_dateRange 0 0 $d 0 0 $d 0 0 $dn]
	}
	{d d} {
	    foreach {d1 d2} $args { break }
	    return [_dateRange 0 0 $d1 0 0 $d2 0 0 $dn]
	}
	{m} {
	    foreach {m} $args { break }
	    set m [lsearch -exact $ml [string toupper $m]]
	    return [_dateRange 0 $m 0 0 $m 0 0 $mn 0]
	}
	{m m} {
	    foreach {m1 m2} $args { break }
	    set m1 [lsearch -exact $ml [string toupper $m1]]
	    set m2 [lsearch -exact $ml [string toupper $m2]]
	    return [_dateRange 0 $m1 0 0 $m2 0 0 $mn 0]
	}
	{y} {
	    foreach y $args { break }
	    return [_dateRange $y 0 0 $y 0 0 $yn 0 0]
	}
	{y y} {
	    foreach {y1 y2} $args { break }
	    return [_dateRange $y1 0 0 $y2 0 0 $yn 0 0]
	}
	{d m} {
	    foreach {d m} $args { break }
	    set m [lsearch -exact $ml [string toupper $m]]
	    return [_dateRange 0 $m $d 0 $m $d 0 $mn $dn]
	}
	{d m d m} {
	    foreach {d1 m1 d2 m2} $args { break }	    
	    set m1 [lsearch -exact $ml [string toupper $m1]]
	    set m2 [lsearch -exact $ml [string toupper $m2]]
	    return [_dateRange 0 $m1 $d1 0 $m2 $d2 0 $mn $dn]
	}
	{m y} {
	    foreach {m y} $args { break }
	    set m [lsearch -exact $ml [string toupper $m]]
	    return [_dateRange $y $m 0 $y $m 0 $yn $mn 0]
	}
	{m y m y} {
	    foreach {m1 y1 m2 y2} $args { break }
	    set m1 [lsearch -exact $ml [string toupper $m1]]
	    set m2 [lsearch -exact $ml [string toupper $m2]]
	    return [_dateRange $y1 $m1 0 $y2 $m2 0 $yn $mn 0]
	}
	{d m y} {
	    foreach {d m y} $args { break }
	    set m [lsearch -exact $ml [string toupper $m]]
	    return [_dateRange $y $m $d $y $m $d $yn $mn $dn]
	}
	{d m y d m y} {
	    foreach {d1 m1 y1 d2 m2 y2} $args { break }
	    set m1 [lsearch -exact $ml [string toupper $m1]]
	    set m2 [lsearch -exact $ml [string toupper $m2]]
	    return [_dateRange $y1 $m1 $d1 $y2 $m2 $d2 $yn $mn $dn]
	}
	default {
	    return -code error "invalid arguments: $args"
	}
    }
}

proc ::js::pac::_timeRange {h1 m1 s1 h2 m2 s2 hn mn sn} {
    set t1 [expr {$h1*3600+$m1*60+$s1}]
    set t2 [expr {$h2*3600+$m2*60+$s2}]
    set tn [expr {$hn*3600+$mn*60+$sn}]
    if { $t1 <= $t2 } {
	return [expr {$t1 <= $tn && $tn <= $t2}]
    } else {
	return [expr {$t1 <= $tn || $tn <= $t2}]
    }
}

proc ::js::pac::timeRange { args } { 
    # Known formats:
    # H1 [GMT/LOC]
    # H1 H2 [GMT/LOC]
    # H1 M1 H2 M2 [GMT/LOC]
    # H1 M1 S1 H2 M2 S2 [GMT/LOC]
    set e [lindex $args end]
    set gmt [lsearch -exact {LOC GMT} [string toupper [lindex $args end]]]
    if { $gmt < 0 } {
	set gmt 0
    } else {
	set args [lrange $args 0 end-1]
    }
    foreach i $args {
	if { ![string is integer -strict $i] } { 
	    return -code error "invalid argument '$i', integer expected: $args"
	}
    }
    set sn [string trimleft [clock format [clock seconds] -format {%S} -gmt $gmt] "0"]
    set mn [string trimleft [clock format [clock seconds] -format {%M} -gmt $gmt] "0"]
    set hn [string trimleft [clock format [clock seconds] -format {%H} -gmt $gmt] "0"]
    if { ![string length $sn] } { set sn 0 }
    if { ![string length $mn] } { set mn 0 }
    if { ![string length $hn] } { set hn 0 }
    switch -exact -- [llength $args] {
	1 {
	    foreach {h} $args { break }
	    return [_timeRange $h 0 0 $h 0 0 $hn 0 0]
	}
	2 {
	    foreach {h1 h2} $args { break }
	    return [_timeRange $h1 0 0 $h2 0 0 $hn 0 0]
	}
	4 {
	    foreach {h1 m1 h2 m2} $args { break }
	    return [_timeRange $h1 $m1 0 $h2 $m2 0 $hn $mn 0]
	}
	6 {
	    foreach {h1 m1 s1 h2 m2 s2} $args { break }
	    return [_timeRange $h1 $m1 $s1 $h2 $m2 $s2 $hn $mn $sn]
	}
	default {
	    return -code error "invalid arguments: $args"
	}
    }
}

proc ::js::pac::addToJsInterp { ji } {
    $ji function ::js::pac::isPlainHostName     1 bool   isPlainHostName
    $ji function ::js::pac::dnsDomainIs         2 bool   dnsDomainIs
    $ji function ::js::pac::localHostOrDomainIs 2 bool   localHostOrDomainIs
    $ji function ::js::pac::isResolvable        1 bool   isResolvable
    $ji function ::js::pac::isInNet             3 bool   isInNet
    $ji function ::js::pac::dnsResolve          1 string dnsResolve
    $ji function ::js::pac::myIpAddress         0 bool   myIpAddress
    $ji function ::js::pac::dnsDomainLevels     1 bool   dnsDomainLevels
    $ji function ::js::pac::shExpMatch          1 bool   shExpMatch
    $ji function ::js::pac::weekdayRange        3 bool   weekdayRange
    $ji function ::js::pac::dateRange           7 bool   dateRange
    $ji function ::js::pac::timeRange           7 bool   timeRange
}
